home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2006 May / PCpro_2006_05.ISO / files / mobile / fma-2.0-stable-setup.exe / {app} / source / uVCard.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2004-10-14  |  23.4 KB  |  778 lines
  1. unit uVCard;
  2.  
  3. {
  4. *******************************************************************************
  5. * Descriptions: vCard object implementaton
  6. * $Source: /cvsroot/fma/fma/uVCard.pas,v $
  7. * $Locker:  $
  8. *
  9. * Todo:
  10. *   - explore source for comments
  11. *
  12. * Change Log:
  13. * $Log: uVCard.pas,v $
  14. * Revision 1.18.6.1  2004/10/14 16:43:28  z_stoichev
  15. * Bugfixes
  16. *
  17. * Revision 1.18  2004/07/26 12:52:17  z_stoichev
  18. * Unicode fixes
  19. *
  20. * Revision 1.17  2004/07/11 12:10:07  voxik
  21. * - Fixed soft line breaks if QP encoding is used
  22. *
  23. * Revision 1.16  2004/07/01 14:42:00  z_stoichev
  24. * vCard note support.
  25. * Bugfixes!!
  26. *
  27. * Revision 1.15  2004/05/21 14:39:13  z_stoichev
  28. * Fixed Contact name changes not saved
  29. * Fixed Display name encoding
  30. *
  31. * Revision 1.14  2004/05/19 18:34:16  z_stoichev
  32. * Build 0.1.0.35c
  33. *
  34. * Revision 1.13  2004/03/26 18:37:40  z_stoichev
  35. * Build 0.1.0.35 RC5
  36. *
  37. * Revision 1.12  2004/03/12 14:41:52  z_stoichev
  38. * Added vCard Grouping support (read only, ignored).
  39. * Added vCard Quoted-Printable Photo decoding.
  40. * Added vCard Unfolding support.
  41. * Added vCard Localy stored phone image (in file).
  42. * Added vCard Preffered phone number support.
  43. * Added vCard Agent support (nested vCards).
  44. * Added vCard UID (GUID) support.
  45. *
  46. *
  47. }
  48.  
  49. interface
  50.  
  51. uses Classes, SysUtils, Jpeg, RxGif, Graphics;
  52.  
  53. type
  54.   TVCard = class(TObject)
  55.   private
  56.     { Private declarations }
  57.     Grouping,PropertyName: Widestring;
  58.     sl: TStringList;
  59.     function GetRaw: TStrings;
  60.     procedure SetRaw(const Value: TStrings);
  61.     procedure setProperty(Value: String);
  62.   public
  63.     { Public declarations }
  64.     Name: Widestring;
  65.     TelWork: Widestring;
  66.     TelHome: Widestring;
  67.     TelFax: Widestring;
  68.     TelCell: Widestring;
  69.     TelOther: Widestring;
  70.     Email: Widestring;
  71.     Title: Widestring;
  72.     Org: Widestring;
  73.     LUID: Widestring;
  74.     VType: Widestring;
  75.     Version: Widestring;
  76.     PhotoType: Integer;
  77.     Photo: TGraphic;
  78.     Surname: Widestring;
  79.     DisplayName: Widestring;
  80.     FullName: Widestring;
  81.     Notes: Widestring;
  82.     TelPref: string; // H = HOME, W = Work, F = Fax, M = CELL, O = Other
  83.     UID: string;
  84.     ModifiedDate: TDateTime;
  85.     constructor Create;
  86.     destructor Destroy; override;
  87.     procedure Clear;
  88.   published  
  89.     property Raw: TStrings read GetRaw write SetRaw;
  90.   end;
  91.  
  92.   //function GetName(Value: String;): String;
  93.   //function GetSurname(Value: String;): String;
  94.   function ExtractNameSurname(Value: Widestring; QP: Boolean): Widestring;
  95.  
  96.   function Str2QP(instr: String): String;
  97.   function QP2Str(instr: String): String;
  98.  
  99.   { Warning! Next function return a new instance of stream! }
  100.   // TODO: function Str2B64(instr: TStream): TStream;
  101.   function B642Str(instr: TStream): TStream;
  102.  
  103. const
  104.   _Code64: string[64]=('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/');
  105.  
  106. implementation
  107.  
  108. uses
  109.   Unit1, TntSystem;
  110.  
  111. function Str2QP(instr: String): String;
  112. var
  113.   i,j,k,m,n: Integer;
  114. begin
  115.   {
  116.   Quoted-Printable lines of text must also be limited to less than 76 characters.
  117.   The 76 characters does not include the CRLF (RFC 822) line break sequence.
  118.   For example a multiple line LABEL property value of:
  119.  
  120.   123 Winding Way
  121.   Any Town, CA 12345
  122.   USA
  123.  
  124.   Would be represented in a Quoted-Printable encoding as:
  125.  
  126.   LABEL;ENCODING=QUOTED-PRINTABLE:123 Winding Way=0D=0A=Any Town, CA 12345=0D=0A=USA
  127.   }
  128.   instr := TrimLeft(instr);
  129.   Result := '';
  130.   j := 0; k := Length(instr);
  131.   for i := 1 to k do begin
  132.     if instr[i] = '=' then begin
  133.       Result := Result + '=' + IntToHex(Ord(instr[i]),2);
  134.       inc(j,2);
  135.     end
  136.     else
  137.       if ((instr[i] >= #32) and (instr[i] <= #126)) then
  138.         Result := Result + instr[i]
  139.       else begin
  140.         Result := Result + '=' + IntToHex(Ord(instr[i]),2);
  141.         inc(j,2);
  142.       end;
  143.     inc(j);
  144.     // should we fold the line? 73 (+ max next 3) <= max 76
  145.     if (j > 73) and (i < k) then begin
  146.       // Folding the result into several lines is possible wherever there may be
  147.       // linear white space (NOT simply LWSP-chars), a CRLF immediately followed
  148.       // by at least one LWSP-char may instead be inserted.
  149.       n := Length(Result);
  150.       m := n;
  151.       { find latest LWSP-char }
  152.       while (m <> 0) and (Result[m] <> ' ') do dec(m);
  153.       { if found insert soft line break and CRLF before it }
  154.       if m <> 0 then begin
  155.         Insert('=' + #13#10,Result,m);
  156.         j := n - m + 1; // count the LWSP-char too
  157.       end;
  158.     end;
  159.   end;
  160. end;
  161.  
  162. function QP2Str(instr: String): String;
  163. begin
  164.   { Remove any LWSP-char prefix and CRLF suffix chars, Realy needed??? }
  165.   instr := Trim(instr);
  166.   Result := '';
  167.  
  168.   while length(instr) > 0 do begin
  169.     // Check for 'soft' line break
  170.     if (instr[1] = '=') and (instr[2] <> ' ') then begin
  171.       Result := Result + chr(StrToInt('$' + instr[2] + instr[3]));
  172.       Delete(instr, 1, 3);
  173.     end
  174.     else begin
  175.       // If 'soft' line break, just delete it
  176.       if instr[1] <> '=' then Result := Result + instr[1];
  177.       Delete(instr, 1, 1);
  178.     end;
  179.   end;
  180. end;
  181.  
  182. function B642Str(instr: TStream): TStream;
  183. var
  184.   S2: TMemoryStream;
  185.   A1: array[1..4] of Byte;
  186.   B1: array[1..3] of Byte;
  187.   Byte_Ptr,Real_Bytes: Integer;
  188.   B: Byte;
  189.   C: Char;
  190. begin
  191.   instr.Seek(0,soFromBeginning);
  192.   S2:= TMemoryStream.Create;
  193.   try
  194.     Byte_Ptr:= Low(A1);
  195.     while instr.Position < instr.Size do
  196.     begin
  197.       instr.ReadBuffer(C, SizeOf(C));
  198.       if C > ' ' then
  199.       begin
  200.         case C of
  201.           'A'..'Z': B:=Ord(C)-65;  {<65..90>  --> <0..25>}
  202.           'a'..'z': B:=Ord(C)-71;  {<97..122>  --> <26..51>}
  203.           '0'..'9': B:=Ord(C)+4;   {<48..57>  --> <52..61>}
  204.           '+': B:=62;{43}
  205.           '/': B:=63;{47}
  206.         else
  207.           {'=': }B:=64;{61}
  208.         end;
  209.         A1[Byte_Ptr]:= B;
  210.         Inc(Byte_Ptr);
  211.         if Byte_Ptr=High(A1)+1 then
  212.         begin
  213.           Byte_ptr:=Low(A1);
  214.           Real_Bytes:=3;
  215.           if A1[1]=64 then Real_Bytes:=0;
  216.           if A1[3]=64 then
  217.           begin
  218.             a1[3]:=0;
  219.             a1[4]:=0;
  220.             real_bytes:=1;
  221.           end;
  222.           if a1[4]=64 then
  223.           begin
  224.             a1[4]:=0;
  225.             real_bytes:=2;
  226.           end;
  227.           b1[1]:=a1[1]*4+(a1[2] div 16);
  228.           b1[2]:=(a1[2] mod 16)*16+(a1[3]div 4);
  229.           b1[3]:=(a1[3] mod 4)*64 +a1[4];
  230.           S2.WriteBuffer(b1, real_bytes);
  231.         end;
  232.       end;
  233.     end;
  234.   finally
  235.     result := S2;
  236.     result.Seek(0,soFromBeginning);
  237.   end;
  238. end;
  239.  
  240. { TVCard }
  241.  
  242. function ExtractNameSurname(Value: Widestring; QP:Boolean): Widestring;
  243. var
  244.   surname,name: widestring;
  245.   function FirstToken(var Text: Widestring): Widestring;
  246.   var
  247.     i: integer;
  248.   begin
  249.     i := Pos(';',Text);
  250.     if i = 0 then i := Length(Text)+1;
  251.     Result := Copy(Text,1,i-1);
  252.     Delete(Text,1,i);
  253.   end;
  254. begin
  255.   {
  256.   String; maximum length 18 bytes. Encapsulates the individual components
  257.   of an objectÆs name. The property value is a concatenation of the Family
  258.   Name (first field), Given Name (second field), Additional Names (third field),
  259.   Name Prefix (fourth field) and Name Suffix (fifth field) strings.
  260.  
  261.   So we have "Family;Given;Additional;Prefix;Suffix". Please note that
  262.   the prefix "N;QUOTED-PRINTABLE;CHARSET=ISO-8859-1:" is already removed.
  263.  
  264.   WARNING!!!! Note that "Additional;Prefix;Suffix" is ignored!
  265.   }
  266.  
  267.   { Dako - Split data into a list was broken, so removed! }
  268.   if QP then Value := QP2Str(Value);
  269.  
  270.   { Value format "Family;Given;Additional;Prefix;Suffix" }
  271.   surname := FirstToken(Value);
  272.   name := FirstToken(Value);
  273.  
  274.   { Result format "Name;Surname" i.e. "Given;Family" }
  275.   Result := name + ';' + surname;
  276. end;
  277.  
  278. procedure TVCard.Clear;
  279. begin
  280.     Name:='';
  281.     Surname := '';
  282.     TelPref := '';
  283.     TelWork:='';
  284.     TelHome:='';
  285.     TelFax:='';
  286.     TelCell:='';
  287.     Email:='';
  288.     TelOther:='';
  289.     Title:='';
  290.     Org:='';
  291.     LUID:='';
  292.     VType:='';
  293.     Version:='';
  294.     DisplayName := '';
  295.     PhotoType := 0;
  296.     FreeAndNil(Photo);
  297.     Grouping := '';
  298.     PropertyName := '';
  299.     UID := '';
  300.     Notes := '';
  301.     ModifiedDate := 0;
  302.     sl.Clear;
  303. end;
  304.  
  305. constructor TVCard.Create;
  306. begin
  307.   inherited;
  308.   sl := TStringList.Create;
  309. end;
  310.  
  311. destructor TVCard.Destroy;
  312. begin
  313.   Clear;
  314.   sl.Free;
  315.   inherited;
  316. end;
  317.  
  318. function TVCard.GetRaw: TStrings;
  319. var
  320.   strTemp : string;
  321.   strN : WideString;
  322.   i: integer;
  323.   //tz: TTimeZoneInformation;
  324. begin
  325.   sl.Clear;
  326.   if VType = '' then
  327.      sl.Add('BEGIN:VCARD')
  328.   else
  329.      sl.Add('BEGIN:' + VType);
  330.  
  331.   if Version = '' then
  332.      sl.Add('VERSION:2.1')
  333.   else
  334.      sl.Add('VERSION:' + Version);
  335.  
  336.   { remove old name/surname from fullname }   
  337.   strN := FullName;
  338.   i := Pos(';',strN);
  339.   if i <> 0 then Delete(strN,1,i);
  340.   i := Pos(';',strN);
  341.   if i = 0 then i := Length(strN);
  342.   Delete(strN,1,i);
  343.   { add new ones to fullname }
  344.   FullName := Surname + ';' + Name;
  345.   if strN <> '' then
  346.     FullName := FullName + ';' + strN;
  347.   strN := FullName;
  348.   
  349.   strTemp := WideStringToUTF8(strN);
  350.   if not Form1.FUseUTF8 or (strTemp = strN) then begin
  351.     strTemp := Str2QP(strN);
  352.     if strN = strTemp then
  353.        sl.add('N:' + strN)
  354.     else
  355.        sl.Add('N;ENCODING=QUOTED-PRINTABLE:' + strTemp);
  356.   end else
  357.     sl.Add('N;CHARSET=UTF-8:' + strTemp);
  358.  
  359.   if DisplayName = '' then begin
  360.     { build default 'file as' field }
  361.     DisplayName := Name;
  362.     if Surname <> '' then
  363.       DisplayName := DisplayName + ' ' + Surname;
  364.     if Name = '' then
  365.       DisplayName := Surname;
  366.   end;
  367.   if DisplayName <> '' then begin
  368.     strTemp := WideStringToUTF8(DisplayName);
  369.     if not Form1.FUseUTF8 or (strTemp = DisplayName) then begin
  370.       strTemp := Str2QP(DisplayName);
  371.       if DisplayName = strTemp then
  372.          sl.add('FN:' + DisplayName)
  373.       else
  374.          sl.Add('FN;ENCODING=QUOTED-PRINTABLE:' + strTemp);
  375.     end else
  376.       sl.Add('FN;CHARSET=UTF-8:' + strTemp);
  377.   end;
  378.  
  379.   if Notes <> '' then begin
  380.      strTemp := WideStringToUTF8(Notes);
  381.      if not Form1.FUseUTF8 or (strTemp = Notes) or (Pos(#13,Notes) <> 0) then begin
  382.        strTemp := Str2QP(Notes);
  383.        if Notes = strTemp then
  384.           sl.add('NOTE:' + Notes)
  385.        else
  386.           sl.Add('NOTE;ENCODING=QUOTED-PRINTABLE:' + strTemp);
  387.      end else
  388.        sl.Add('NOTE;CHARSET=UTF-8:' + strTemp);
  389.   end;
  390.   
  391.   if Title <> '' then begin
  392.      strTemp := WideStringToUTF8(Title);
  393.      if not Form1.FUseUTF8 or (strTemp = Title) then begin
  394.        strTemp := Str2QP(Title);
  395.        if Title = strTemp then
  396.           sl.add('TITLE:' + Title)
  397.        else
  398.           sl.Add('TITLE;ENCODING=QUOTED-PRINTABLE:' + strTemp);
  399.      end else
  400.        sl.Add('TITLE;CHARSET=UTF-8:' + strTemp);
  401.   end;
  402.  
  403.   if Org <> '' then begin
  404.      strTemp := WideStringToUTF8(Org);
  405.      if not Form1.FUseUTF8 or (strTemp = Org) then begin
  406.        strTemp := Str2QP(Org);
  407.        if Org = strTemp then
  408.           sl.add('ORG:' + Org)
  409.        else
  410.           sl.Add('ORG;ENCODING=QUOTED-PRINTABLE:' + strTemp);
  411.      end else
  412.        sl.Add('ORG;CHARSET=UTF-8:' + strTemp);
  413.   end;
  414.  
  415.   if Email <> '' then begin
  416.      sl.add('EMAIL;INTERNET;PREF:' + Email)
  417.   end;
  418.  
  419.   if TelHome <> '' then begin
  420.     if TelPref <> 'H' then
  421.       sl.add('TEL;HOME:' + TelHome)
  422.     else
  423.       sl.add('TEL;HOME;PREF:' + TelHome)
  424.   end;
  425.   if TelWork <> '' then begin
  426.     if TelPref <> 'W' then
  427.       sl.add('TEL;WORK:' + TelWork)
  428.     else
  429.       sl.add('TEL;WORK;PREF:' + TelWork)
  430.   end;
  431.   if TelCell <> '' then begin
  432.     if TelPref <> 'M' then
  433.       sl.add('TEL;CELL:' + TelCell)
  434.     else
  435.       sl.add('TEL;CELL;PREF:' + TelCell)
  436.   end;
  437.   if TelFax <> '' then begin
  438.     if TelPref <> 'F' then
  439.       sl.add('TEL;FAX:' + TelFax)
  440.     else
  441.       sl.add('TEL;FAX;PREF:' + TelFax)
  442.   end;
  443.   if TelOther <> '' then begin
  444.     if TelPref <> 'O' then
  445.       sl.add('TEL:' + TelOther)
  446.     else
  447.       sl.add('TEL;PREF:' + TelOther)
  448.   end;
  449.  
  450.   // TODO: Optional, add support for photo image
  451.  
  452.   if UID <> '' then begin
  453.      sl.add('UID:' + UID)
  454.   end;
  455.  
  456.   if LUID <> '' then begin
  457.      sl.add('X-IRMC-LUID:' + LUID)
  458.   end;
  459.  
  460.   // REV:20040701T095208Z
  461.   //GetTimeZoneInformation(tz);
  462.   //sl.add('REV:'+FormatDateTime('yyyymmdd"T"hhnn',ModifiedDate)+Format('%.2dZ',[-tz.Bias div 15]));
  463.   sl.add('REV:'+FormatDateTime('yyyymmdd"T"hhnnss"Z"',ModifiedDate));
  464.  
  465.   if VType = '' then
  466.      sl.Add('END:VCARD')
  467.   else
  468.      sl.Add('END:' + VType);
  469.   Result := sl;
  470. end;
  471.  
  472. procedure TVCard.setProperty(Value: String);
  473. const
  474.   ValueRaw: String = '';
  475.   function IsField(FName,Value: string): boolean;
  476.   var
  477.     i,j: integer;
  478.   begin
  479.     i := Length(FName);
  480.     j := Length(Value);
  481.     Result := (Pos(FName,Value) = 1) and ((i = j) or
  482.       (Value[i+1] in [';',':']) or (FName[i] in [';',':']));
  483.   end;
  484. var
  485.   str,grp,grpdescr,nme,nmedescr: Widestring;
  486.   i,j: integer;
  487.   procedure CheckUTFs(var Value: String);
  488.   begin
  489.     if Pos('UTF-7',Value) <> 0 then
  490.       Value := UTF7ToWideString(Value)
  491.     else
  492.       if Form1.FUseUTF8 and (Pos('UTF-8',Value) <> 0) then
  493.         Value := UTF8Decode(Value);
  494.   end;
  495.   procedure ProcessRaw(var Value: String);
  496.   begin
  497.     { find end pos+1 of propery name }
  498.     i := Pos(';',Value);
  499.     j := Pos(':',Value);
  500.     if i < j then j := i;
  501.     { find start pos-1 of propery name }
  502.     i := Pos('.',Value);
  503.     if i > j then i := 0;
  504.     { get grouping name, if any }
  505.     grp := UpperCase(Copy(Value,1,i-1));
  506.     grpdescr := Copy(Value,i+1,length(Value));
  507.     { get property name }
  508.     nme := UpperCase(Copy(Value,i+1,j-i-1));
  509.     { remove grouping, leave property name at the begining of Value }
  510.     Delete(Value,1,i);
  511.     { get full name (with desctiptions) }
  512.     i := Pos(':',Value);
  513.     nmedescr := Copy(Value,1,i-1);
  514.     { keep values }
  515.     if Grouping = grp then begin
  516.       {
  517.       The grouping of a comment property with a telephone property is shown in the following example:
  518.  
  519.       A.TEL;HOME:+1-213-555-1234
  520.       A.NOTE:This is my vacation home
  521.  
  522.       In this case PropertyName="TEL;HOME", Grouping="A", nme="NOTE", grpdescr="This is my vacation home"
  523.       }
  524.       // TODO: use grouping description somehow
  525.     end
  526.     else
  527.       Grouping := grp;
  528.     PropertyName := nmedescr;
  529.  
  530.     if IsField('BEGIN',Value) then
  531.       Vtype := copy(Value, pos(':', Value) + 1, length(Value));
  532.     if Pos('VERSION',Value) = 1 then
  533.       Version := copy(Value, pos(':', Value) + 1, length(Value));
  534.  
  535.     if IsField('N',Value) then begin
  536.       CheckUTFs(Value);
  537.       FullName := copy(Value, pos(':', Value) + 1, length(Value));
  538.       str := ExtractNameSurname(FullName, Pos('QUOTED-PRINTABLE',nmedescr) <> 0);
  539.       Name := Copy(str, 1,Pos(';', str) - 1);
  540.       Surname := Copy(str,Pos(';', str) + 1, length(str));
  541.     end;
  542.  
  543.     if IsField('FN',Value) then begin
  544.       CheckUTFs(Value);
  545.       if Pos('QUOTED-PRINTABLE',nmedescr) <> 0 then
  546.         DisplayName := QP2Str(copy(Value, pos(':', Value) + 1, length(Value)))
  547.       else
  548.         DisplayName := copy(Value, pos(':', Value) + 1, length(Value));
  549.     end;
  550.  
  551.     if IsField('TEL;WORK',Value) then begin
  552.       if Pos('PREF',nmedescr) <> 0 then TelPref := 'W';
  553.       TelWork := copy(Value, pos(':', Value) + 1, length(Value));
  554.     end;
  555.     if IsField('TEL;HOME',Value) then begin
  556.       if Pos('PREF',nmedescr) <> 0 then TelPref := 'H';
  557.       TelHome := copy(Value, pos(':', Value) + 1, length(Value));
  558.     end;
  559.     if IsField('TEL;FAX',Value) then begin
  560.       if Pos('PREF',nmedescr) <> 0 then TelPref := 'F';
  561.       TelFax := copy(Value, pos(':', Value) + 1, length(Value));
  562.     end;
  563.     if IsField('TEL;CELL',Value) then begin
  564.       if Pos('PREF',nmedescr) <> 0 then TelPref := 'M';
  565.       TelCell := copy(Value, pos(':', Value) + 1, length(Value));
  566.     end;
  567.     { phone type not specified }
  568.     if IsField('TEL:',Value) then begin
  569.       if Pos('PREF',nmedescr) <> 0 then TelPref := 'O';
  570.       TelOther := copy(Value, pos(':', Value) + 1, length(Value));
  571.     end;
  572.  
  573.     if IsField('TITLE',Value) then begin
  574.       CheckUTFs(Value);
  575.       if Pos('QUOTED-PRINTABLE',nmedescr) <> 0 then
  576.           Title := QP2Str(copy(Value, pos(':', Value) + 1, length(Value)))
  577.       else
  578.           Title := copy(Value, pos(':', Value) + 1, length(Value));
  579.     end;
  580.  
  581.     if IsField('ORG',Value) then begin
  582.       CheckUTFs(Value);
  583.       if Pos('QUOTED-PRINTABLE',nmedescr) <> 0 then
  584.           Org := QP2Str(copy(Value, pos(':', Value) + 1, length(Value)))
  585.       else
  586.           Org := copy(Value, pos(':', Value) + 1, length(Value));
  587.     end;
  588.  
  589.     if IsField('EMAIL',Value) then
  590.       // TODO: Add support for several e-mail addresses
  591.       if (Pos('INTERNET',nmedescr) <> 0) and (Pos('PREF',nmedescr) <> 0) then
  592.           Email := copy(Value, pos(':', Value) + 1, length(Value));
  593.  
  594.     if IsField('NOTE',Value) then begin
  595.       CheckUTFs(Value);
  596.       if Pos('QUOTED-PRINTABLE',nmedescr) <> 0 then
  597.         Notes := QP2Str(copy(Value, pos(':', Value) + 1, length(Value)))
  598.       else
  599.         Notes := copy(Value, pos(':', Value) + 1, length(Value));
  600.     end;
  601.  
  602.     { TODO: Add ModifiedDate support }
  603.     // REV:20040701T095208Z
  604.  
  605.     if IsField('UID',Value) then
  606.       UID := copy(Value, pos(':', Value) + 1, length(Value));
  607.  
  608.     if IsField('X-IRMC-LUID',Value) then
  609.       LUID := copy(Value, pos(':', Value) + 1, length(Value));
  610.  
  611.     Value := '';
  612.   end;
  613. begin
  614.   { unfold a vCard raw, if needed }
  615.   if Value = '' then begin
  616.     if ValueRaw <> '' then ProcessRaw(ValueRaw); // this will clear ValueRaw
  617.   end
  618.   else begin
  619.     if Value[1] = ' ' then begin
  620.       {
  621.       Individual lines within the vCard data stream are delimited by the (RFC 822) line break,
  622.       which is a CRLF sequence (ASCII decimal 13, followed by ASCII decimal 10). Long lines
  623.       of text can be split into a multiple-line representation using the RFC 822 "folding"
  624.       technique. That is, wherever there may be linear white space (NOT simply LWSP-chars),
  625.       a CRLF immediately followed by at least one LWSP-char may instead be inserted.
  626.       For example the line:
  627.  
  628.       NOTE:This is a very long description that exists on a long line.
  629.  
  630.       Can be represented as:
  631.  
  632.       NOTE:This is a very long description
  633.         that exists on a long line.
  634.  
  635.       The process of moving from this folded multiple-line representation of a property definition
  636.       to its single line representation is called "unfolding". Unfolding is accomplished by regarding
  637.       CRLF immediately followed by a LWSP-char as equivalent to the LWSP-char.
  638.       }
  639.       ValueRaw := ValueRaw + ' ' + TrimLeft(Value);
  640.       exit;
  641.     end
  642.     else begin
  643.       if ValueRaw <> '' then ProcessRaw(ValueRaw);
  644.       ValueRaw := Value;
  645.     end;
  646.   end;
  647. end;
  648.  
  649. procedure TVCard.SetRaw(const Value: TStrings);
  650. var
  651.   i: Integer;
  652.   s: string;
  653.   isAgent,isBody,isPhoto,isPhotoQP: boolean;
  654.   PhotoStream: TStream;
  655.   stream: TStream;
  656. begin
  657.   Clear;
  658.   isAgent := False;
  659.   isBody := False;
  660.   isPhoto := False;
  661.   isPhotoQP := False; // default is BASE64
  662.   PhotoStream := nil;
  663.  
  664.   { Process incoming data }
  665.   for i := 0 to Value.Count - 1 do begin
  666.     { check for nested vCard (Agent) into specified vCard }
  667.     if pos('AGENT', Value.Strings[i]) = 1 then isAgent := True;
  668.     if isAgent then begin
  669.       {
  670.       This property specifies information about another person who will act on behalf of the vCard object.
  671.       Typically this would be an area administrator, assistant, or secretary for the individual. A key
  672.       characteristic of the Agent property is that it represents somebody or something which is separately
  673.       addressable.
  674.       }
  675.       // ignore Agent vCard!
  676.       // SetProperty(Value.Strings[i]);
  677.       if pos('END', Value.Strings[i]) = 1 then isAgent := False;
  678.       Continue;
  679.     end;
  680.  
  681.     if pos('BEGIN', Value.Strings[i]) = 1 then isBody := True
  682.     else if pos('END', Value.Strings[i]) = 1 then isBody := False
  683.     else if pos('PHOTO', Value.Strings[i]) = 1 then isPhoto :=True
  684.     else if Value.Strings[i] = '' then
  685.         isPhoto := False;
  686.  
  687.     if isBody then begin
  688.         if isPhoto then begin
  689.           if Pos('PHOTO', Value.Strings[i]) = 1 then begin
  690.             { check image encoding }
  691.             if Pos('TYPE=GIF', Value.Strings[i]) <> 0 then
  692.               PhotoType := 1
  693.             else if Pos('TYPE=JPEG', Value.Strings[i]) <> 0 then
  694.               PhotoType := 2;
  695.             {
  696.             In the case of the vCard being transported within a MIME email message, the property value
  697.             can be specified as being located in a separate MIME entity with the "Content-ID" value, or
  698.             "CID" for short. In this case, the property value is the Content-ID for the MIME entity
  699.             containing the property value. In addition, the property value can be specified as being
  700.             located out on the network within some Internet resource with the "URL" value. In this case,
  701.             the property value is the Uniform Resource Locator for the Internet resource containing the
  702.             property value. The following specifies a value not located inline with the vCard but out
  703.             in the Internet:
  704.  
  705.             PHOTO;VALUE=URL;TYPE=GIF:http://www.abc.com/dir_photos/my_photo.gif
  706.             SOUND;VALUE=CONTENT-ID:<jsmith.part3.960817T083000.xyzMail@host1.com
  707.             }
  708.             if Pos('VALUE=URL', Value.Strings[i]) <> 0 then begin
  709.               s := copy(Value.Strings[i], pos(':', Value.Strings[i]) + 1, length(Value.Strings[i]));
  710.               if Pos('file:///',s) = 1 then begin
  711.                 Delete(s,1,8);
  712.                 try
  713.                   PhotoStream := TFileStream.Create(s,fmOpenRead);
  714.                 except
  715.                   PhotoType := 0; // ignore image on error (file not found etc.)
  716.                 end;
  717.               end
  718.               else
  719.                 // TODO: Add support for vCard external images (http)
  720.                 PhotoType := 0; // ignore image - not implemented
  721.             end
  722.             else if Pos('VALUE=CONTENT-ID', Value.Strings[i]) <> 0 then begin
  723.               // TODO: Add support for vCard MIME content-id
  724.               PhotoType := 0; // ignore image - not implemented
  725.             end
  726.             else begin
  727.               { begin collecting image data... }
  728.               isPhotoQP := Pos('QUOTED-PRINTABLE',Value.Strings[i]) <> 0;
  729.               sl.Add(Trim(copy(Value.Strings[i], pos(':', Value.Strings[i]) + 1, length(Value.Strings[i]))));
  730.             end;
  731.           end
  732.           else begin
  733.             { ...adding more image data }
  734.             sl.add(Trim(Value.Strings[i]));
  735.           end;
  736.         end
  737.         else
  738.           SetProperty(Value.Strings[i]);
  739.     end;
  740.   end;
  741.   { Flush any unfolded vCard raw }
  742.   SetProperty('');
  743.   
  744.   { check if photo image exists }
  745.   stream := TMemoryStream.Create;
  746.   try
  747.     sl.SaveToStream(stream);
  748.     sl.Clear;
  749.     if (PhotoStream = nil) and (PhotoType <> 0) then begin
  750.       if isPhotoQP then begin
  751.         sl.Text := QP2Str(StringReplace(sl.Text,#13#10,'',[rfReplaceAll]));
  752.         PhotoStream := TMemoryStream.Create;
  753.         sl.SaveToStream(PhotoStream);
  754.       end
  755.       else
  756.         PhotoStream := b642str(stream); // this will create a stream instance
  757.     end;
  758.     try
  759.       case PhotoType of
  760.         1: begin
  761.             Photo := TGIFImage.Create;
  762.             Photo.LoadFromStream(PhotoStream)
  763.         end;
  764.         2: begin
  765.             Photo := TJPEGImage.Create;
  766.             Photo.LoadFromStream(PhotoStream)
  767.         end;
  768.       end;
  769.     finally
  770.       PhotoStream.Free;
  771.     end;
  772.   finally
  773.     stream.Free;
  774.   end;  
  775. end;
  776.  
  777. end.
  778.